
static int
opaque_typecast (unsigned char from_type, VOID_STAR from_p,
      		unsigned int num, unsigned char to_type, VOID_STAR to_p)
{
   unsigned int i;
   SLang_MMT_Type **from = (SLang_MMT_Type**)from_p;
   SLang_MMT_Type **to   = (SLang_MMT_Type**)to_p;

   /* Not fully working yet, as typeof() still reports original type */
   for (i=0; i < num; i++) {
	to[i] = from[i];
	if (from[i] != NULL)
	   SLang_inc_mmt(from[i]);
   }

   return 1;
}

SLtype slirp_type_to_sltype(unsigned int typeid)
{
   if (typeid > Slirp_Num_Opaque_Types) {
	SLang_verror(SL_TYPE_MISMATCH,"unknown SLIRP type");
	return SLANG_UNDEFINED_TYPE;
   }

   return Slirp_Opaque_Types[typeid]->class->cl_data_type;
}

SLang_MMT_Type*
create_opaque_mmt(unsigned int typeid, void *instance, unsigned int owns_ref)
{
   if (typeid > Slirp_Num_Opaque_Types) {
	SLang_verror(SL_TYPE_MISMATCH,"attempt to pop unknown opaque type");
	return NULL;
   }

   {

   SLang_MMT_Type *mmt = NULL;
   Slirp_Opaque *ot = (Slirp_Opaque*) SLmalloc(sizeof(Slirp_Opaque));
   if (ot != NULL) {
      ot->instance = instance;
      ot->owns_ref = owns_ref;
      ot->type = Slirp_Opaque_Types[typeid];
      mmt = SLang_create_mmt (ot->type->class->cl_data_type, (VOID_STAR) ot);
      if (mmt == NULL)
	 SLfree((char*)ot);
   }

   return mmt;

   }
}

int SLang_push_opaque(unsigned int id, void *instance, unsigned int owns_ref)
{
   SLang_MMT_Type *mmt;

   if (instance == NULL)
      return SLang_push_null();

   mmt = create_opaque_mmt(id, instance, owns_ref);
   if (NULL == mmt)
      return -1;

   return SLang_push_mmt(mmt);
}

int
SLang_pop_opaque(unsigned int typeid,Slirp_Opaque **opaque,SLang_MMT_Type **mmt)
{
   Slirp_Opaque *ot;

   *mmt = NULL;

   if (typeid > Slirp_Num_Opaque_Types) {
	SLang_verror(SL_TYPE_MISMATCH,"attempt to pop unknown opaque type");
	goto failure_return;
   }

   if (NULL == (*mmt = SLang_pop_mmt( 
			Slirp_Opaque_Types[typeid]->class->cl_data_type)))
      goto failure_return;

   if ( (ot = (Slirp_Opaque*) SLang_object_from_mmt (*mmt)) && ot->instance) {
	*opaque = ot;
	return 0;
   }

   failure_return:

   SLang_free_mmt (*mmt);
   return -1;
}

int
pop_opaque_or_null(unsigned int id, Slirp_Opaque **opaque, SLang_MMT_Type **mmt)
{
   if (SLANG_NULL_TYPE == SLang_peek_at_stack ()) { 
	*opaque = NULL;
	*mmt    = NULL;
	return SLang_pop_null ();
   }

   return SLang_pop_opaque(id, opaque, mmt);
}

int pop_cstruct_or_null(void **pstruct, SLang_CStruct_Field_Type *layout)
{
   if (SLANG_NULL_TYPE == SLang_peek_at_stack ()) {
	*pstruct = NULL;
	return SLang_pop_null ();
   }
   return SLang_pop_cstruct(*pstruct,layout);
}

int pop_obj_or_null(SLtype type, void **obj)
{
   if (SLANG_NULL_TYPE == SLang_peek_at_stack ()) { 
	*obj = NULL;
	return SLang_pop_null ();
   }

   /* Because MMT types require caller to explicitly free the MMT
      associated with the object being managed, MMT types are not
      handled here */

   switch(type) {

	case SLANG_ANY_TYPE:
	   return SLang_pop_anytype((SLang_Any_Type**)obj);

	case SLANG_REF_TYPE:
	   return SLang_pop_ref((SLang_Ref_Type**)obj);

	case SLANG_STRING_TYPE:
	   return SLang_pop_slstring ((char**)obj);

	default:
	   SLang_verror (SL_NOT_IMPLEMENTED,
		"pop_obj_or_null: does not support %d type",type);
	   return -1;
   }

}

int Slirp_finalize_ref(Slirp_Ref *sref, SLtype sltype)
{
   int status;

   if (sref->ref) {
	status = SLang_assign_to_ref (sref->ref, sltype, sref->data);
	SLang_free_ref(sref->ref);
   }
   else {
	SLang_free_array(sref->array);
	status = 0;
   }
   return status;
}

int pop_string_or_null (char **s)
{   
   return pop_obj_or_null ( SLANG_STRING_TYPE, (void**)s);
}

int pop_ref_or_null(SLang_Ref_Type **r)
{
   return pop_obj_or_null ( SLANG_REF_TYPE, (void**)r);
}

int pop_anytype_or_null(SLang_Any_Type **r)
{
   return pop_obj_or_null (SLANG_ANY_TYPE, (void**)r);
}

SLtype Slirp_Opaque_Id;
static void destroy_opaque(unsigned char type, VOID_STAR w)
{
   Slirp_Opaque *ot = (Slirp_Opaque*)w;

   (void) type;

   if (ot->type->finalizer != NULL)
      (*ot->type->finalizer) (ot->instance);

   SLfree( (char*)w );
}


static Slirp_Type*
allocate_type(SLang_Class_Type *class, Slirp_Type *parent, FINALIZER f)
{
   Slirp_Type  *t = (Slirp_Type*) SLmalloc(sizeof(Slirp_Type));
   if (t != NULL) {
	t->class = class;
	t->typeid  = ++Slirp_Num_Opaque_Types;		/* typeids are >= 1 */
	t->parent = parent;
	t->finalizer = f;
	Slirp_Opaque_Types[t->typeid] = t;
   }
   return t;
}

unsigned int
allocate_opaque(char *name, FINALIZER finalizer, char *subtypes[],
      						unsigned int parentid)
{
   /* Returning from here with anything but a nonpositive id is fatal */

   Slirp_Type *type , *parent = NULL;
   SLang_Class_Type *class = SLclass_allocate_class (name);
   if (class == NULL) return SLANG_UNDEFINED_TYPE;

   (void) SLclass_set_destroy_function (class, destroy_opaque);
   if (-1 == SLclass_register_class (class, SLANG_VOID_TYPE,
				     sizeof(Slirp_Opaque),
				     SLANG_CLASS_TYPE_MMT))
	return SLANG_UNDEFINED_TYPE;

   type = parent = Slirp_Opaque_Types[parentid];

   while (type) {

	/* Support downcasting ancestor types to this type */
	if (-1 == SLclass_add_typecast (type->class->cl_data_type, 
				class->cl_data_type, opaque_typecast, 1))
		return SLANG_UNDEFINED_TYPE;

	/* Support upcasting this type to each ancestor type */
	if (-1 == SLclass_add_typecast (class->cl_data_type,
			 type->class->cl_data_type, opaque_typecast, 1))
		return SLANG_UNDEFINED_TYPE;

	type = type->parent;
   }

   if ( (type = allocate_type(class,parent,finalizer)) != NULL) {
	while (*subtypes) {
	   if ( allocate_type(class,type,finalizer) != NULL)
		subtypes++;
	   else
		return SLANG_UNDEFINED_TYPE;
	}
   }
   else
	return SLANG_UNDEFINED_TYPE;

   return type->typeid;
}

SLtype GladeXML_SLtype;
unsigned int GladeXML_Id;
static char *GladeXML_Id_Subtypes[] = { "GladeXML*", NULL};

Slirp_Type **Slirp_Opaque_Types;
unsigned int Slirp_Num_Opaque_Types;

int allocate_glade_opaque_types(void)
{
   if (!SLang_is_defined("_slirp_initialized")) { 
	Slirp_Opaque_Types = NULL;
	Slirp_Num_Opaque_Types = 0;
	(void)SLang_load_string("public variable _slirp_initialized=1;");
   }
   Slirp_Opaque_Types = (Slirp_Type**) SLrealloc((char*)Slirp_Opaque_Types, 
		(Slirp_Num_Opaque_Types + 207) * sizeof(Slirp_Type*));

   if (Slirp_Opaque_Types == NULL) return -1;

   Slirp_Opaque_Types[0] = NULL;

   GladeXML_Id = allocate_opaque("GladeXML",
		NULL,
		GladeXML_Id_Subtypes, (unsigned int) GObject_Id);
   if (GladeXML_Id == SLANG_UNDEFINED_TYPE) return -1;
   GladeXML_SLtype = slirp_type_to_sltype(GladeXML_Id);

   return 0;
}
